home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
pctchnqs
/
1991
/
number3
/
shades
/
shades.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-06-13
|
6KB
|
232 lines
{ shades.pas -- Sample After Dark TPW DLL by Tom Swan }
{$X+} { Enable extended syntax }
library Shades;
{$R shades.res} { Link in resources from this file }
uses WinTypes, WinProcs, ADUnit;
const
max_Index = 100; { Maximum number of shapes visible }
dx1: Integer = 4; { Delta values for controlling }
dy1: Integer = 10; { the animation's personality. }
dx2: Integer = 3;
dy2: Integer = 9;
type
ShapeRec = record { Describes each graphic shape }
X1, Y1, X2, Y2 : Integer; { Location }
Color: TColorRef; { RGB color }
end;
var
ShapeArray: array[0 .. max_Index - 1] of ShapeRec;
Index: Integer; { Index for ShapeArray }
Erasing: Boolean; { True if erasing old Shapes }
{----- Shades Graphics Routines -----}
{- Return -1 if N < 0 or +1 if N >= 0 }
function Sign(N: Integer): Integer;
begin
if N < 0 then Sign := -1 else Sign := 1
end;
{- Create new shape, direction, and color }
procedure MakeNewShape(Dc: HDC; R: TRect; Index: Integer);
procedure NewCoord(var C, Change: Integer; Max: Integer;
var Color: TColorRef);
var
Temp: Integer;
begin
Temp := C + Change;
if (Temp < 0) or (Temp > Max) then
begin
Change := Sign(-Change) * (3 + Random(12));
repeat
Color := GetNearestColor(Dc,
RGB(Random(256), Random(256), Random(256)))
until Color <> GetBkColor(Dc)
end else
C := Temp
end;
begin
with ShapeArray[Index] do
begin
NewCoord(X1, dx1, R.Right, Color);
NewCoord(Y1, dy1, R.Bottom, Color);
NewCoord(X2, dx2, R.Right, Color);
NewCoord(Y2, dy2, R.Bottom, Color)
end
end;
{- Draw or erase a shape identified by Index }
procedure DrawShape(Dc: HDC; Index: Integer);
var
OldPen, Pen: HPen;
OldROP: Integer;
begin
with ShapeArray[Index] do
if X1 >= 0 then
begin
Pen := CreatePen(ps_Solid, 1, Color);
OldPen := SelectObject(Dc, Pen);
OldROP := SetROP2(Dc, r2_XorPen);
Rectangle(Dc, X1, Y1, X2, Y2);
SelectObject(Dc, OldPen);
DeleteObject(Pen);
SetROP2(Dc, OldROP)
end
end;
{- Initialize graphics variables }
procedure InitShades;
var
I: Integer;
begin
Index := 0;
Erasing := False;
for I := 0 to max_Index - 1 do
ShapeArray[I].X1 := -1
end;
{----- After Dark Functions -----}
{- Early initializations. Not used }
function DoPreInitialize: Integer;
begin
DoPreInitialize := 1
end;
{- Initialize new graphics }
function DoInitialize: Integer;
begin
InitShades;
DoInitialize := noError
end;
{- Blank the display. Optional }
function DoBlank: Integer;
var
R: TRect;
begin
with LpModule^.ptRgnSize do
SetRect(R, 0, 0, X, Y);
FillRect(DC, R, GetStockObject(black_Brush))
end;
{- Draw one "frame" of the animation }
function DoDrawFrame: Integer;
var
R: TRect;
OldIndex: Integer;
begin
with LPSystem^.ptScreenSize do
SetRect(R, 0, 0, X, Y);
OldIndex := Index;
if Index = max_Index - 1 then
begin
Index := 0;
Erasing := True
end else
Inc(Index);
if Erasing then DrawShape(Dc, Index);
ShapeArray[Index] := ShapeArray[OldIndex];
MakeNewShape(Dc, R, Index);
DrawShape(Dc, Index);
DoDrawFrame := noError
end;
{- Shutdown animation }
function DoClose: Integer;
begin
InitShades; { Reinitialize }
DoClose := noError
end;
{- Initialize control panel. Not used }
function DoSelected: Integer;
begin
DoSelected := noError
end;
{- Perform custom about-box graphics. Not used }
function DoAbout: Integer;
begin
DoAbout := noError
end;
{- Respond to control panel buttons. Not used }
function DoButtonMessage(IButtonID: Integer): Integer;
begin
DoButtonMessage := noError
end;
{- Message dispatcher. DO NOT MODIFY! }
function Module(IMessage: Integer; HDrawDC: HDC;
HADSystem: THandle): Integer; export;
var
IError: Integer;
I: Integer;
begin
DC := HDrawDC; { Save display context in global var }
HSystem := HADSystem; { Save AD system handle in global var }
IError := 0; { Unless changed by a function result }
LpSystem := GlobalLock(HSystem);
if LpSystem <> nil then
begin
LpModule := GlobalLock(LpSystem^.hModuleInfo);
if LpModule <> nil then
begin
case IMessage of
preInitialize:
IError := DoPreInitialize;
initialize:
begin
Randomize;
IError := Initialize
end;
blank:
IError := DoBlank;
drawFrame:
IError := DoDrawFrame;
adClose:
IError := DoClose;
moduleSelected:
begin
LpModule^.hModule := hLibInst;
for I := 0 to 3 do
LpModule^.iControlID[I] := I + 1;
IError := DoSelected
end;
about:
IError := DoAbout;
buttonMessage .. buttonMessage + 3:
IError := DoButtonMessage(IMessage - buttonMessage);
end;
GlobalUnlock(LpSystem^.HModuleInfo)
end;
GlobalUnlock(HSystem)
end;
Module := IError
end;
{- Export DLL public routines }
exports
Module index 1;
{- DLL entry code }
begin
HLibInst := HInstance
end.
{--------------------------------------------------------------
Copyright (c) 1991 by Tom Swan. All rights reserved.
Revision 1.00 Date: 6/12/1991
---------------------------------------------------------------}